home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / eval.lisp < prev    next >
Lisp/Scheme  |  1992-12-09  |  51KB  |  1,292 lines
  1. ;;; -*- Package: eval; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: eval.lisp,v 1.20 92/09/07 15:37:19 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This file contains the interpreter.  We first convert to the compiler's
  15. ;;; IR1 and interpret that.
  16. ;;;
  17. ;;; Written by Rob MacLachlan and Bill Chiles.
  18. ;;;
  19.  
  20. (in-package "EVAL")
  21.  
  22. (export '(internal-eval *eval-stack-trace* *internal-apply-node-trace*
  23.             *interpreted-function-cache-minimum-size*
  24.             *interpreted-function-cache-threshold*
  25.             flush-interpreted-function-cache
  26.             trace-eval interpreted-function-p
  27.             interpreted-function-lambda-expression
  28.             interpreted-function-closure
  29.             interpreted-function-name
  30.             interpreted-function-arglist
  31.             interpreted-function-type
  32.             make-interpreted-function))
  33.  
  34.  
  35. ;;;; Interpreter stack.
  36.  
  37. (defvar *eval-stack* (make-array 100)
  38.   "This is the interpreter's evaluation stack.")
  39. (defvar *eval-stack-top* 0
  40.   "This is the next free element of the interpreter's evaluation stack.")
  41.  
  42. ;;; Setting this causes the stack operations to dump a trace.
  43. ;;;
  44. (defvar *eval-stack-trace* nil)
  45.  
  46.  
  47. ;;; EVAL-STACK-PUSH -- Internal.
  48. ;;;
  49. ;;; Push value on *eval-stack*, growing the stack if necessary.  This returns
  50. ;;; value.  We save *eval-stack-top* in a local and increment the global before
  51. ;;; storing value on the stack to prevent a GC timing problem.  If we stored
  52. ;;; value on the stack using *eval-stack-top* as an index, and we GC'ed before
  53. ;;; incrementing *eval-stack-top*, then INTERPRETER-GC-HOOK would clear the
  54. ;;; location.
  55. ;;;
  56. (defun eval-stack-push (value)
  57.   (let ((len (length (the simple-vector *eval-stack*))))
  58.     (when (= len *eval-stack-top*)
  59.       (when *eval-stack-trace* (format t "[PUSH: growing stack.]~%"))
  60.       (let ((new-stack (make-array (ash len 1))))
  61.     (replace new-stack *eval-stack* :end1 len :end2 len)
  62.     (setf *eval-stack* new-stack))))
  63.   (let ((top *eval-stack-top*))
  64.     (when *eval-stack-trace* (format t "pushing ~D.~%" top))
  65.     (incf *eval-stack-top*)
  66.     (setf (svref *eval-stack* top) value)))
  67.  
  68. ;;; EVAL-STACK-POP -- Internal.
  69. ;;;
  70. ;;; This returns the last value pushed on *eval-stack* and decrements the top
  71. ;;; pointer.  We forego setting elements off the end of the stack to nil for GC
  72. ;;; purposes because there is a *before-gc-hook* to take care of this for us.
  73. ;;; However, because of the GC hook, we must be careful to grab the value
  74. ;;; before decrementing *eval-stack-top* since we could GC between the
  75. ;;; decrement and the reference, and the hook would clear the stack slot.
  76. ;;;
  77. (defun eval-stack-pop ()
  78.   (when (zerop *eval-stack-top*)
  79.     (error "Attempt to pop empty eval stack."))
  80.   (let* ((new-top (1- *eval-stack-top*))
  81.      (value (svref *eval-stack* new-top)))
  82.     (when *eval-stack-trace* (format t "popping ~D --> ~S.~%" new-top value))
  83.     (setf *eval-stack-top* new-top)
  84.     value))
  85.  
  86. ;;; EVAL-STACK-EXTEND -- Internal.
  87. ;;;
  88. ;;; This allocates n locations on the stack, bumping the top pointer and
  89. ;;; growing the stack if necessary.  We set new slots to nil in case we GC
  90. ;;; before having set them; we don't want to hold on to potential garbage
  91. ;;; from old stack fluctuations.
  92. ;;;
  93. (defun eval-stack-extend (n)
  94.   (let ((len (length (the simple-vector *eval-stack*))))
  95.     (when (> (+ n *eval-stack-top*) len)
  96.       (when *eval-stack-trace* (format t "[EXTEND: growing stack.]~%"))
  97.       (let ((new-stack (make-array (+ n (ash len 1)))))
  98.     (replace new-stack *eval-stack* :end1 len :end2 len)
  99.     (setf *eval-stack* new-stack))))
  100.   (let ((new-top (+ *eval-stack-top* n)))
  101.   (when *eval-stack-trace* (format t "extending to ~D.~%" new-top))
  102.     (do ((i *eval-stack-top* (1+ i)))
  103.     ((= i new-top))
  104.       (setf (svref *eval-stack* i) nil))
  105.     (setf *eval-stack-top* new-top)))
  106.  
  107. ;;; EVAL-STACK-SHRINK -- Internal.
  108. ;;;
  109. ;;; The anthesis of EVAL-STACK-EXTEND.
  110. ;;;
  111. (defun eval-stack-shrink (n)
  112.   (when *eval-stack-trace*
  113.     (format t "shrinking to ~D.~%" (- *eval-stack-top* n)))
  114.   (decf *eval-stack-top* n))
  115.  
  116. ;;; EVAL-STACK-SET-TOP -- Internal.
  117. ;;;
  118. ;;; This is used to shrink the stack back to a previous frame pointer.
  119. ;;;
  120. (defun eval-stack-set-top (ptr)
  121.   (when *eval-stack-trace* (format t "setting top to ~D.~%" ptr))
  122.   (setf *eval-stack-top* ptr))
  123.  
  124.  
  125. ;;; EVAL-STACK-LOCAL -- Internal.
  126. ;;;
  127. ;;; This returns a local variable from the current stack frame.  This is used
  128. ;;; for references the compiler represents as a lambda-var leaf.  This is a
  129. ;;; macro for SETF purposes.
  130. ;;;
  131. (defmacro eval-stack-local (fp offset)
  132.   `(svref *eval-stack* (+ ,fp ,offset)))
  133.  
  134.  
  135. ;;;; Interpreted functions:
  136.  
  137. (defstruct (eval-function
  138.         (:print-function
  139.          (lambda (s stream d)
  140.            (declare (ignore d))
  141.            (format stream "#<EVAL-FUNCTION ~S>"
  142.                (eval-function-name s)))))
  143.   ;;
  144.   ;; The name of this interpreted function, or NIL if none specified.
  145.   (name nil)
  146.   ;;
  147.   ;; This function's debug arglist.
  148.   (arglist nil)
  149.   ;;
  150.   ;; A lambda that can be converted to get the definition.
  151.   (lambda nil)
  152.   ;;
  153.   ;; If this function has been converted, then this is the XEP.  If this is
  154.   ;; false, then the function is not in the cache (or is in the process of
  155.   ;; being removed.)
  156.   (definition nil :type (or c::clambda null))
  157.   ;;
  158.   ;; The number of consequtive GCs that this function has been unused.  This is
  159.   ;; used to control cache replacement.
  160.   (gcs 0 :type c::index)
  161.   ;;
  162.   ;; True if Lambda has been converted at least once, and thus warnings should
  163.   ;; be suppressed on additional conversions.
  164.   (converted-once nil))
  165.  
  166.  
  167. (defvar *interpreted-function-cache-minimum-size* 25
  168.   "If the interpreted function cache has more functions than this come GC time,
  169.   then attempt to prune it according to
  170.   *INTERPRETED-FUNCTION-CACHE-THRESHOLD*.")
  171.  
  172. (defvar *interpreted-function-cache-threshold* 3
  173.   "If an interpreted function goes uncalled for more than this many GCs, then
  174.   it is eligible for flushing from the cache.")
  175.  
  176. (proclaim '(type c::index
  177.          *interpreted-function-cache-minimum-size*
  178.          *interpreted-function-cache-threshold*))
  179.  
  180.  
  181. ;;; The list of EVAL-FUNCTIONS that have translated definitions.
  182. ;;;
  183. (defvar *interpreted-function-cache* nil)
  184. (proclaim '(type list *interpreted-function-cache*))
  185.  
  186.  
  187. ;;; MAKE-INTERPRETED-FUNCTION  --  Interface
  188. ;;;
  189. ;;;    Return a function that will lazily convert Lambda when called, and will
  190. ;;; cache translations.
  191. ;;;
  192. (defun make-interpreted-function (lambda)
  193.   (let ((eval-fun (make-eval-function :lambda lambda
  194.                       :arglist (second lambda))))
  195.     #'(lambda (&rest args)
  196.     (let ((fun (eval-function-definition eval-fun))
  197.           (args (cons (length args) args)))
  198.       (setf (eval-function-gcs eval-fun) 0)
  199.       (internal-apply (or fun (convert-eval-fun eval-fun))
  200.               args '#())))))
  201.  
  202.  
  203. ;;; GET-EVAL-FUNCTION  --  Internal
  204. ;;;
  205. (defun get-eval-function (x)
  206.   (let ((res (system:find-if-in-closure #'eval-function-p x)))
  207.     (assert res)
  208.     res))
  209.  
  210.  
  211. ;;; CONVERT-EVAL-FUN  --  Internal
  212. ;;;
  213. ;;;    Eval a FUNCTION form, grab the definition and stick it in.
  214. ;;;
  215. (defun convert-eval-fun (eval-fun)
  216.   (declare (type eval-function eval-fun))
  217.   (let* ((new (eval-function-definition
  218.            (get-eval-function
  219.         (internal-eval `#',(eval-function-lambda eval-fun)
  220.                    (eval-function-converted-once eval-fun))))))
  221.     (setf (eval-function-definition eval-fun) new)
  222.     (setf (eval-function-converted-once eval-fun) t)
  223.     (let ((name (eval-function-name eval-fun)))
  224.       (setf (c::leaf-name new) name)
  225.       (setf (c::leaf-name (c::main-entry (c::functional-entry-function new)))
  226.         name))
  227.     (push eval-fun *interpreted-function-cache*)
  228.     new))
  229.  
  230.  
  231. ;;; INTERPRETED-FUNCTION-LAMDBA-EXPRESSION  --  Interface
  232. ;;;
  233. ;;;    Get the CLAMBDA for the XEP, then look at the inline expansion info in
  234. ;;; the real function.
  235. ;;;
  236. (defun interpreted-function-lambda-expression (x)
  237.   (let* ((eval-fun (get-eval-function x))
  238.      (lambda (eval-function-lambda eval-fun)))
  239.     (if lambda
  240.     (values lambda nil (eval-function-name eval-fun))
  241.     (let ((fun (c::functional-entry-function
  242.             (eval-function-definition eval-fun))))
  243.       (values (c::functional-inline-expansion fun)
  244.           (if (let ((env (c::functional-lexenv fun)))
  245.             (or (c::lexenv-functions env)
  246.                 (c::lexenv-variables env)
  247.                 (c::lexenv-blocks env)
  248.                 (c::lexenv-tags env)))
  249.               t nil)
  250.           (or (eval-function-name eval-fun)
  251.               (c::component-name
  252.                (c::block-component
  253.             (c::node-block (c::lambda-bind fun))))))))))
  254.  
  255.  
  256. ;;; INTERPRETED-FUNCTION-TYPE  --  Interface
  257. ;;;
  258. ;;;    Return a FUNCTION-TYPE describing an eval function.  We just grab the
  259. ;;; LEAF-TYPE of the definition, converting the definition if not currently
  260. ;;; cached.
  261. ;;;
  262. (defvar *already-looking-for-type-of* nil)
  263. ;;;
  264. (defun interpreted-function-type (fun)
  265.   (if (member fun *already-looking-for-type-of*)
  266.       (specifier-type 'function)
  267.       (let* ((*already-looking-for-type-of*
  268.           (cons fun *already-looking-for-type-of*))
  269.          (eval-fun (get-eval-function fun))
  270.          (def (or (eval-function-definition eval-fun)
  271.               (system:without-gcing
  272.                (convert-eval-fun eval-fun)
  273.                (eval-function-definition eval-fun)))))
  274.     (c::leaf-type (c::functional-entry-function def)))))
  275.  
  276.  
  277. ;;; 
  278. ;;; INTERPRETED-FUNCTION-{NAME,ARGLIST}  --  Interface
  279. ;;;
  280. (defun interpreted-function-name (x)
  281.   (multiple-value-bind (ig1 ig2 res)
  282.                (interpreted-function-lambda-expression x)
  283.     (declare (ignore ig1 ig2))
  284.     res))
  285. ;;;
  286. (defun (setf interpreted-function-name) (val x)
  287.   (let* ((eval-fun (get-eval-function x))
  288.      (def (eval-function-definition eval-fun)))
  289.     (when def
  290.       (setf (c::leaf-name def) val)
  291.       (setf (c::leaf-name (c::main-entry (c::functional-entry-function def)))
  292.         val))
  293.     (setf (eval-function-name eval-fun) val)))
  294. ;;;
  295. (defun interpreted-function-arglist (x)
  296.   (eval-function-arglist (get-eval-function x)))
  297. ;;;
  298. (defun (setf interpreted-function-arglist) (val x)
  299.   (setf (eval-function-arglist (get-eval-function x)) val))
  300.  
  301.  
  302. ;;; INTERPRETED-FUNCTION-ENVIRONMENT  --  Interface
  303. ;;;
  304. ;;;    The environment should be the only SIMPLE-VECTOR in the closure.  We
  305. ;;; have to throw in the EVAL-FUNCTION-P test, since structure are currently
  306. ;;; also SIMPLE-VECTORs.
  307. ;;;
  308. (defun interpreted-function-closure (x)
  309.   (system:find-if-in-closure #'(lambda (x)
  310.                  (and (simple-vector-p x)
  311.                       (not (eval-function-p x))))
  312.                  x))
  313.  
  314.  
  315. ;;; INTERPRETER-GC-HOOK  --  Internal
  316. ;;;
  317. ;;;    Clear the unused portion of the eval stack, and flush the definitions of
  318. ;;; all functions in the cache that haven't been used enough.
  319. ;;;
  320. (defun interpreter-gc-hook ()
  321.   (let ((len (length (the simple-vector *eval-stack*))))
  322.     (do ((i *eval-stack-top* (1+ i)))
  323.     ((= i len))
  324.       (setf (svref *eval-stack* i) nil)))
  325.  
  326.   (let ((num (- (length *interpreted-function-cache*)
  327.         *interpreted-function-cache-minimum-size*)))
  328.     (when (plusp num)
  329.       (setq *interpreted-function-cache*
  330.         (delete-if #'(lambda (x)
  331.                (when (>= (eval-function-gcs x)
  332.                      *interpreted-function-cache-threshold*)
  333.                  (setf (eval-function-definition x) nil)
  334.                  t))
  335.                *interpreted-function-cache*
  336.                :count num))))
  337.  
  338.   (dolist (fun *interpreted-function-cache*)
  339.     (incf (eval-function-gcs fun))))
  340. ;;;
  341. (pushnew 'interpreter-gc-hook ext:*before-gc-hooks*)
  342.  
  343.  
  344. ;;; FLUSH-INTERPRETED-FUNCTION-CACHE  --  Interface
  345. ;;;
  346. (defun flush-interpreted-function-cache ()
  347.   "Clear all entries in the eval function cache.  This allows the internal
  348.   representation of the functions to be reclaimed, and also lazily forces
  349.   macroexpansions to be recomputed."
  350.   (dolist (fun *interpreted-function-cache*)
  351.     (setf (eval-function-definition fun) nil))
  352.   (setq *interpreted-function-cache* ()))
  353.  
  354.  
  355. ;;;; INTERNAL-APPLY-LOOP macros.
  356.  
  357. ;;; These macros are intimately related to INTERNAL-APPLY-LOOP.  They assume
  358. ;;; variables established by this function, and they assume they can return
  359. ;;; from a block by that name.  This is sleazy, but we justify it as follows:
  360. ;;; They are so specialized in use, and their invocation became lengthy, that
  361. ;;; we allowed them to slime some access to things in their expanding
  362. ;;; environment.  These macros don't really extend our Lisp syntax, but they do
  363. ;;; provide some template expansion service; it is these cleaner circumstance
  364. ;;; that require a more rigid programming style.
  365. ;;;
  366. ;;; Since these are macros expanded almost solely for c::combination nodes,
  367. ;;; they cascade from the end of this logical page to the beginning here.
  368. ;;; Therefore, it is best you start looking at them from the end of this
  369. ;;; section, backwards from normal scanning mode for Lisp code.
  370. ;;;
  371.  
  372. ;;; DO-COMBINATION -- Internal.
  373. ;;;
  374. ;;; This runs a function on some arguments from the stack.  If the combination
  375. ;;; occurs in a tail recursive position, then we do the call such that we
  376. ;;; return from tail-p-function with whatever values the call produces.  With a
  377. ;;; :local call, we have to restore the stack to its previous frame before
  378. ;;; doing the call.  The :full call mechanism does this for us.  If it is NOT a
  379. ;;; tail recursive call, and we're in a multiple value context, then then push
  380. ;;; a list of the returned values.  Do the same thing if we're in a :return
  381. ;;; context.  Push a single value, without listifying it, for a :single value
  382. ;;; context.  Otherwise, just call for side effect.
  383. ;;;
  384. ;;; Node is the combination node, and cont is its continuation.  Frame-ptr
  385. ;;; is the current frame pointer, and closure is the current environment for
  386. ;;; closure variables.  Call-type is either :full or :local, and when it is
  387. ;;; local, lambda is the IR1 lambda to apply.
  388. ;;;
  389. ;;; This assumes the following variables are present: node, cont, frame-ptr,
  390. ;;; and closure.  It also assumes a block named internal-apply-loop.
  391. ;;;
  392. (defmacro do-combination (call-type lambda mv-or-normal)
  393.   (let* ((args (gensym))
  394.      (calling-closure (gensym))
  395.      (invoke-fun (ecase mv-or-normal
  396.                (:mv-call 'mv-internal-invoke)
  397.                (:normal 'internal-invoke)))
  398.      (args-form (ecase mv-or-normal
  399.               (:mv-call
  400.                `(mv-eval-stack-args
  401.              (length (c::mv-combination-args node))))
  402.               (:normal
  403.                `(eval-stack-args (c:lambda-eval-info-args-passed
  404.                       (c::lambda-info ,lambda))))))
  405.      (call-form (ecase call-type
  406.               (:full `(,invoke-fun
  407.                    (length (c::basic-combination-args node))))
  408.               (:local `(internal-apply
  409.                 ,lambda ,args-form
  410.                 (compute-closure node ,lambda frame-ptr
  411.                          closure)
  412.                 nil))))
  413.      (tailp-call-form
  414.       (ecase call-type
  415.         (:full `(return-from
  416.              internal-apply-loop
  417.              ;; INVOKE-FUN takes care of the stack itself.
  418.              (,invoke-fun (length (c::basic-combination-args node))
  419.                   frame-ptr)))
  420.         (:local `(let ((,args ,args-form)
  421.                (,calling-closure
  422.                 (compute-closure node ,lambda frame-ptr closure)))
  423.                ;; No need to clean up stack slots for GC due to
  424.                ;; ext:*before-gc-hook*.
  425.                (eval-stack-set-top frame-ptr)
  426.                (return-from
  427.             internal-apply-loop 
  428.             (internal-apply ,lambda ,args ,calling-closure
  429.                     nil)))))))
  430.     `(cond ((c::node-tail-p node)
  431.         ,tailp-call-form)
  432.        (t
  433.         (ecase (c::continuation-info cont)
  434.           ((:multiple :return)
  435.            (eval-stack-push (multiple-value-list ,call-form)))
  436.           (:single
  437.            (eval-stack-push ,call-form))
  438.           (:unused ,call-form))))))
  439.  
  440. ;;; SET-BLOCK -- Internal.
  441. ;;;
  442. ;;; This sets the variable block in INTERNAL-APPLY-LOOP, and it announces this
  443. ;;; by setting set-block-p for later loop iteration maintenance.
  444. ;;;
  445. (defmacro set-block (exp)
  446.   `(progn
  447.      (setf block ,exp)
  448.      (setf set-block-p t)))
  449.  
  450. ;;; CHANGE-BLOCKS -- Internal.
  451. ;;;
  452. ;;; This sets all the iteration variables in INTERNAL-APPLY-LOOP to iterate
  453. ;;; over a new block's nodes.  Block-exp is optional because sometimes we have
  454. ;;; already set block, and we only need to bring the others into agreement.
  455. ;;; If we already set block, then clear the variable that announces this,
  456. ;;; set-block-p.
  457. ;;;
  458. (defmacro change-blocks (&optional block-exp)
  459.   `(progn
  460.      ,(if block-exp
  461.       `(setf block ,block-exp)
  462.       `(setf set-block-p nil))
  463.      (setf node (c::continuation-next (c::block-start block)))
  464.      (setf last-cont (c::node-cont (c::block-last block)))))
  465.  
  466.  
  467. ;;; This controls printing visited nodes in INTERNAL-APPLY-LOOP.  We use it
  468. ;;; here, and INTERNAL-INVOKE uses it to print function call looking output
  469. ;;; to further describe c::combination nodes.
  470. ;;;
  471. (defvar *internal-apply-node-trace* nil)
  472. ;;;
  473. (defun maybe-trace-funny-fun (node name &rest args)
  474.   (when *internal-apply-node-trace*
  475.     (format t "(~S ~{ ~S~})  c~S~%"
  476.         name args (c::cont-num (c::node-cont node)))))
  477.  
  478.  
  479. ;;; DO-FUNNY-FUNCTION -- Internal.
  480. ;;;
  481. ;;; This implements the intention of the virtual function name.  This is a
  482. ;;; macro because some of these actions must occur without a function call.
  483. ;;; For example, calling a dispatch function to implement special binding would
  484. ;;; be a no-op because returning from that function would cause the system to
  485. ;;; undo any special bindings it established.
  486. ;;;
  487. ;;; NOTE: update C:ANNOTATE-COMPONENT-FOR-EVAL and/or c::undefined-funny-funs
  488. ;;; if you add or remove branches in this routine.
  489. ;;;
  490. ;;; This assumes the following variables are present: node, cont, frame-ptr,
  491. ;;; args, closure, block, and last-cont.  It also assumes a block named
  492. ;;; internal-apply-loop.
  493. ;;;
  494. (defmacro do-funny-function (funny-fun-name)
  495.   (let ((name (gensym)))
  496.     `(let ((,name ,funny-fun-name))
  497.        (ecase ,name
  498.      (c::%special-bind
  499.       (let ((value (eval-stack-pop))
  500.         (global-var (eval-stack-pop)))
  501.         (maybe-trace-funny-fun node ,name global-var value)
  502.         (system:%primitive bind value (c::global-var-name global-var))))
  503.      (c::%special-unbind
  504.       ;; Throw away arg telling me which special, and tell the dynamic
  505.       ;; binding mechanism to unbind one variable.
  506.       (eval-stack-pop)
  507.       (maybe-trace-funny-fun node ,name)
  508.       (system:%primitive unbind))
  509.      (c::%catch
  510.       (let* ((tag (eval-stack-pop))
  511.          (nlx-info (eval-stack-pop))
  512.          (fell-through-p nil)
  513.          ;; Ultimately THROW and CATCH will fix the interpreter's stack
  514.          ;; since this is necessary for compiled CATCH's and those in
  515.          ;; the initial top level function.
  516.          (stack-top *eval-stack-top*)
  517.          (values
  518.           (multiple-value-list
  519.            (catch tag
  520.              (maybe-trace-funny-fun node ,name tag)
  521.              (multiple-value-setq (block node cont last-cont)
  522.                (internal-apply-loop (c::continuation-next cont)
  523.                         frame-ptr lambda args closure))
  524.              (setf fell-through-p t)))))
  525.         (cond (fell-through-p
  526.            ;; We got here because we just saw the C::%CATCH-BREAKUP
  527.            ;; funny function inside the above recursive call to
  528.            ;; INTERNAL-APPLY-LOOP.  Therefore, we just received and
  529.            ;; stored the current state of evaluation for falling
  530.            ;; through.
  531.            )
  532.           (t
  533.            ;; Fix up the interpreter's stack after having thrown here.
  534.            ;; We won't need to do this in the final implementation.
  535.            (eval-stack-set-top stack-top)
  536.            ;; Take the values received in the list bound above, and
  537.            ;; massage them into the form expected by the continuation
  538.            ;; of the non-local-exit info.
  539.            (ecase (c::continuation-info
  540.                (c::nlx-info-continuation nlx-info))
  541.              (:single
  542.               (eval-stack-push (car values)))
  543.              ((:multiple :return)
  544.               (eval-stack-push values))
  545.              (:unused))
  546.            ;; We want to continue with the code after the CATCH body.
  547.            ;; The non-local-exit info tells us where this is, but we
  548.            ;; know that block only contains a call to the funny
  549.            ;; function C::%NLX-ENTRY, which simply is a place holder
  550.            ;; for the compiler IR1.  We want to skip the target block
  551.            ;; entirely, so we say it is the block we're in now and say
  552.            ;; the current cont is the last-cont.  This makes the COND
  553.            ;; at the end of INTERNAL-APPLY-LOOP do the right thing.
  554.            (setf block (c::nlx-info-target nlx-info))
  555.            (setf cont last-cont)))))
  556.      (c::%unwind-protect
  557.       ;; Cleanup function not pushed due to special-case :UNUSED
  558.       ;; annotation in ANNOTATE-COMPONENT-FOR-EVAL.
  559.       (let* ((nlx-info (eval-stack-pop))
  560.          (fell-through-p nil)
  561.          (stack-top *eval-stack-top*))
  562.         (unwind-protect
  563.         (progn
  564.           (maybe-trace-funny-fun node ,name)
  565.           (multiple-value-setq (block node cont last-cont)
  566.             (internal-apply-loop (c::continuation-next cont)
  567.                      frame-ptr lambda args closure))
  568.           (setf fell-through-p t))
  569.           (cond (fell-through-p
  570.              ;; We got here because we just saw the
  571.              ;; C::%UNWIND-PROTECT-BREAKUP funny function inside the
  572.              ;; above recursive call to INTERNAL-APPLY-LOOP.
  573.              ;; Therefore, we just received and stored the current
  574.              ;; state of evaluation for falling through.
  575.              )
  576.             (t
  577.              ;; Fix up the interpreter's stack after having thrown here.
  578.              ;; We won't need to do this in the final implementation.
  579.              (eval-stack-set-top stack-top)
  580.              ;;
  581.              ;; Push some bogus values for exit context to keep the
  582.              ;; MV-BIND in the UNWIND-PROTECT translation happy. 
  583.              (eval-stack-push '(nil nil 0))
  584.              (let ((node (c::continuation-next
  585.                   (c::block-start
  586.                    (car (c::block-succ
  587.                      (c::nlx-info-target nlx-info)))))))
  588.                (internal-apply-loop node frame-ptr lambda args
  589.                         closure)))))))
  590.      ((c::%catch-breakup c::%unwind-protect-breakup c::%continue-unwind)
  591.       ;; This shows up when we locally exit a CATCH body -- fell through.
  592.       ;; Return the current state of evaluation to the previous invocation
  593.       ;; of INTERNAL-APPLY-LOOP which happens to be running in the
  594.       ;; c::%catch branch of this code.
  595.       (maybe-trace-funny-fun node ,name)
  596.       (return-from internal-apply-loop
  597.                (values block node cont last-cont)))
  598.      (c::%nlx-entry
  599.       (maybe-trace-funny-fun node ,name)
  600.       ;; This just marks a spot in the code for CATCH, UNWIND-PROTECT, and
  601.       ;; non-local lexical exits (GO or RETURN-FROM).
  602.       ;; Do nothing since c::%catch does it all when it catches a THROW.
  603.       ;; Do nothing since c::%unwind-protect does it all when
  604.       ;; it catches a THROW.
  605.       )
  606.      (c::%more-arg-context
  607.       (let* ((fixed-arg-count (1+ (eval-stack-pop)))
  608.          ;; Add 1 to actual fixed count for extra arg expected by
  609.          ;; external entry points (XEP) which some IR1 lambdas have.
  610.          ;; The extra arg is the number of arguments for arg count
  611.          ;; consistency checking.  C::%MORE-ARG-CONTEXT always runs
  612.          ;; within an XEP, so the lambda has an extra arg.
  613.          (more-args (nthcdr fixed-arg-count args)))
  614.         (maybe-trace-funny-fun node ,name fixed-arg-count)
  615.         (assert (eq (c::continuation-info cont) :multiple))
  616.         (eval-stack-push (list more-args (length more-args)))))
  617.      (c::%unknown-values
  618.       (error "C::%UNKNOWN-VALUES should never be in interpreter's IR1."))
  619.      (c::%lexical-exit-breakup
  620.       ;; We see this whenever we locally exit the extent of a lexical
  621.       ;; target.  That is, we are truly locally exiting an extent we could
  622.       ;; have non-locally lexically exited.  Return the :fell-through flag
  623.       ;; and the current state of evaluation to the previous invocation
  624.       ;; of INTERNAL-APPLY-LOOP which happens to be running in the
  625.       ;; c::entry branch of INTERNAL-APPLY-LOOP.
  626.       (maybe-trace-funny-fun node ,name)
  627.       ;;
  628.       ;; Discard the NLX-INFO arg...
  629.       (eval-stack-pop)
  630.       (return-from internal-apply-loop
  631.                (values :fell-through block node cont last-cont)))))))
  632.  
  633.  
  634. ;;; COMBINATION-NODE -- Internal.
  635. ;;;
  636. ;;; This expands for the two types of combination nodes INTERNAL-APPLY-LOOP
  637. ;;; sees.  Type is either :mv-call or :normal.  Node is the combination node,
  638. ;;; and cont is its continuation.  Frame-ptr is the current frame pointer, and
  639. ;;; closure is the current environment for closure variables.
  640. ;;;
  641. ;;; Most of the real work is done by DO-COMBINATION.  This first determines if
  642. ;;; the combination node describes a :full call which DO-COMBINATION directly
  643. ;;; handles.  If the call is :local, then we either invoke an IR1 lambda, or we
  644. ;;; just bind some LET variables.  If the call is :local, and type is :mv-call,
  645. ;;; then we can only be binding multiple values.  Otherwise, the combination
  646. ;;; node describes a function known to the compiler, but this may be a funny
  647. ;;; function that actually isn't ever defined.  We either take some action for
  648. ;;; the funny function or do a :full call on the known true function, but the
  649. ;;; interpreter doesn't do optimizing stuff for functions known to the
  650. ;;; compiler.
  651. ;;;
  652. ;;; This assumes the following variables are present: node, cont, frame-ptr,
  653. ;;; and closure.  It also assumes a block named internal-apply-loop.
  654. ;;;
  655. (defmacro combination-node (type)
  656.   (let* ((kind (gensym))
  657.      (fun (gensym))
  658.      (lambda (gensym))
  659.      (letp (gensym))
  660.      (letp-bind (ecase type
  661.               (:mv-call nil)
  662.               (:normal
  663.                `((,letp (eq (c::functional-kind ,lambda) :let))))))
  664.      (local-branch
  665.       (ecase type
  666.         (:mv-call
  667.          `(store-mv-let-vars ,lambda frame-ptr
  668.                  (length (c::mv-combination-args node))))
  669.         (:normal
  670.          `(if ,letp
  671.           (store-let-vars ,lambda frame-ptr)
  672.           (do-combination :local ,lambda ,type))))))
  673.     `(let ((,kind (c::basic-combination-kind node))
  674.        (,fun (c::basic-combination-fun node)))
  675.        (cond ((member ,kind '(:full :error))
  676.           (do-combination :full nil ,type))
  677.          ((eq ,kind :local)
  678.           (let* ((,lambda (c::ref-leaf (c::continuation-use ,fun)))
  679.              ,@letp-bind)
  680.         ,local-branch))
  681.          ((eq (c::continuation-info ,fun) :unused)
  682.           (assert (typep ,kind 'c::function-info))
  683.           (do-funny-function (c::continuation-function-name ,fun)))
  684.          (t
  685.           (assert (typep ,kind 'c::function-info))
  686.           (do-combination :full nil ,type))))))
  687.  
  688.  
  689. (defun trace-eval (on)
  690.   (setf *eval-stack-trace* on)
  691.   (setf *internal-apply-node-trace* on))
  692.  
  693.  
  694. ;;;; INTERNAL-EVAL:
  695.  
  696. (proclaim '(special lisp::*already-evaled-this*))
  697.  
  698. ;;; INTERNAL-EVAL  --  Interface
  699. ;;;
  700. ;;;    Evaluate an arbitary form.  We convert the form, then call internal
  701. ;;; apply on it.  If *ALREADY-EVALED-THIS* is true, then we bind it to NIL
  702. ;;; around the apply to limit the inhibition to the lexical scope of the
  703. ;;; EVAL-WHEN.
  704. ;;;
  705. (defun internal-eval (form &optional quietly)
  706.   (let ((res (c:compile-for-eval form quietly)))
  707.     (if lisp::*already-evaled-this*
  708.     (let ((lisp::*already-evaled-this* nil))
  709.       (internal-apply res nil '#()))
  710.     (internal-apply res nil '#()))))
  711.  
  712.  
  713. ;;; MAKE-INDIRECT-VALUE-CELL -- Internal.
  714. ;;;
  715. ;;; Later this will probably be the same weird internal thing the compiler
  716. ;;; makes to represent these things.
  717. ;;;
  718. (defun make-indirect-value-cell (value)
  719.   (list value))
  720. ;;;
  721. (defmacro indirect-value (value-cell)
  722.   `(car ,value-cell))
  723.  
  724.  
  725. ;;; VALUE -- Internal.
  726. ;;;
  727. ;;; This passes on a node's value appropriately, possibly returning from
  728. ;;; function to do so.  When we are tail-p, don't push the value, return it on
  729. ;;; the system's actual call stack; when we blow out of function this way, we
  730. ;;; must return the interpreter's stack to the its state before this call to
  731. ;;; function.  When we're in a multiple value context or heading for a return
  732. ;;; node, we push a list of the value for easier handling later.  Otherwise,
  733. ;;; just push the value on the interpreter's stack.
  734. ;;;
  735. (defmacro value (node info value frame-ptr function)
  736.   `(cond ((c::node-tail-p ,node)
  737.       (eval-stack-set-top ,frame-ptr)
  738.       (return-from ,function ,value))
  739.      ((member ,info '(:multiple :return) :test #'eq)
  740.       (eval-stack-push (list ,value)))
  741.      (t (assert (eq ,info :single))
  742.         (eval-stack-push ,value))))))
  743.  
  744.  
  745. (defun maybe-trace-nodes (node)
  746.   (when *internal-apply-node-trace*
  747.     (format t "<~A-node> c~S~%"
  748.         (type-of node)
  749.         (c::cont-num (c::node-cont node)))))
  750.  
  751. ;;; INTERNAL-APPLY -- Internal.
  752. ;;;
  753. ;;; This interprets lambda, a compiler IR1 data structure representing a
  754. ;;; function, applying it to args.  Closure is the environment in which to run
  755. ;;; lambda, the variables and such closed over to form lambda.  The call occurs
  756. ;;; on the interpreter's stack, so save the current top and extend the stack
  757. ;;; for this lambda's call frame.  Then store the args into locals on the
  758. ;;; stack.
  759. ;;;
  760. ;;; Args is the list of arguments to apply to.  If IGNORE-UNUSED is true, then
  761. ;;; values for un-read variables are present in the argument list, and must be
  762. ;;; discarded (always true except in a local call.)  Args may run out of values
  763. ;;; before vars runs out of variables (in the case of an XEP with optionals);
  764. ;;; we just do CAR of nil and store nil.  This is not the proper defaulting
  765. ;;; (which is done by explicit code in the XEP.)
  766. ;;;
  767. (defun internal-apply (lambda args closure &optional (ignore-unused t))
  768.   (let ((frame-ptr *eval-stack-top*))
  769.     (eval-stack-extend (c:lambda-eval-info-frame-size (c::lambda-info lambda)))
  770.     (do ((vars (c::lambda-vars lambda) (cdr vars))
  771.      (args args))
  772.     ((null vars))
  773.       (let ((var (car vars)))
  774.     (cond ((c::leaf-refs var)
  775.            (setf (eval-stack-local frame-ptr (c::lambda-var-info var))
  776.              (if (c::lambda-var-indirect var)
  777.              (make-indirect-value-cell (pop args))
  778.              (pop args))))
  779.           (ignore-unused (pop args)))))
  780.     (internal-apply-loop (c::lambda-bind lambda) frame-ptr lambda args
  781.              closure)))
  782.  
  783. ;;; INTERNAL-APPLY-LOOP -- Internal.
  784. ;;;
  785. ;;; This does the work of INTERNAL-APPLY.  This also calls itself recursively
  786. ;;; for certain language features, such as CATCH.  First is the node at which
  787. ;;; to start interpreting.  Frame-ptr is the current frame pointer for
  788. ;;; accessing local variables.  Lambda is the IR1 lambda from which comes the
  789. ;;; nodes a given call to this function processes, and closure is the
  790. ;;; environment for interpreting lambda.  Args is the argument list for the
  791. ;;; lambda given to INTERNAL-APPLY, and we have to carry it around with us
  792. ;;; in case of more-arg or rest-arg processing which is represented explicitly
  793. ;;; in the compiler's IR1.
  794. ;;;
  795. ;;; Due to having a truly tail recursive interpreter, some of the branches
  796. ;;; handling a given node need to RETURN-FROM this routine.  Also, some calls
  797. ;;; this makes to do work for it must occur in tail recursive positions.
  798. ;;; Because of this required access to this function lexical environment and
  799. ;;; calling positions, we often are unable to break off logical chunks of code
  800. ;;; into functions.  We have written macros intended solely for use in this
  801. ;;; routine, and due to all the local stuff they need to access and length
  802. ;;; complex calls, we have written them to sleazily access locals from this
  803. ;;; routine.  In addition to assuming a block named internal-apply-loop exists,
  804. ;;; they set and reference the following variables: node, cont, frame-ptr,
  805. ;;; closure, block, last-cont, and set-block-p.
  806. ;;;
  807. (defun internal-apply-loop (first frame-ptr lambda args closure)
  808.   (declare (optimize (debug-info 2)))
  809.   (let* ((block (c::node-block first))
  810.      (last-cont (c::node-cont (c::block-last block)))
  811.      (node first)
  812.      (set-block-p nil))
  813.       (loop
  814.     (let ((cont (c::node-cont node)))
  815.       (etypecase node
  816.         (c::ref
  817.          (maybe-trace-nodes node)
  818.          (let ((info (c::continuation-info cont)))
  819.            (unless (eq info :unused)
  820.          (value node info (leaf-value node frame-ptr closure)
  821.             frame-ptr internal-apply-loop))))
  822.         (c::combination
  823.          (maybe-trace-nodes node)
  824.          (combination-node :normal))
  825.         (c::cif
  826.          (maybe-trace-nodes node)
  827.          ;; IF nodes always occur at the end of a block, so pick another.
  828.          (set-block (if (eval-stack-pop)
  829.                 (c::if-consequent node)
  830.                 (c::if-alternative node))))
  831.         (c::bind
  832.          (maybe-trace-nodes node)
  833.          ;; Ignore bind nodes since INTERNAL-APPLY extends the stack for
  834.          ;; all of a lambda's locals, and the c::combination branch
  835.          ;; handles LET binds (moving values off stack top into locals).
  836.          )
  837.         (c::cset
  838.          (maybe-trace-nodes node)
  839.          (let ((info (c::continuation-info cont))
  840.            (res (set-leaf-value node frame-ptr closure
  841.                     (eval-stack-pop))))
  842.            (unless (eq info :unused)
  843.          (value node info res frame-ptr internal-apply-loop))))
  844.         (c::entry
  845.          (maybe-trace-nodes node)
  846.          (let ((info (cdr (assoc node (c:lambda-eval-info-entries
  847.                        (c::lambda-info lambda))))))
  848.            ;; No info means no-op entry for CATCH or UNWIND-PROTECT.
  849.            (when info
  850.          ;; Store stack top for restoration in local exit situation
  851.          ;; in c::exit branch.
  852.          (setf (eval-stack-local frame-ptr
  853.                      (c:entry-node-info-st-top info))
  854.                *eval-stack-top*)
  855.          (let ((tag (c:entry-node-info-nlx-tag info)))
  856.            (when tag
  857.              ;; Non-local lexical exit (someone closed over a
  858.              ;; GO tag or BLOCK name).
  859.              (let ((unique-tag (cons nil nil))
  860.                values)
  861.                (setf (eval-stack-local frame-ptr tag) unique-tag)
  862.                (if (eq cont last-cont)
  863.                (change-blocks (car (c::block-succ block)))
  864.                (setf node (c::continuation-next cont)))
  865.                (loop
  866.              (multiple-value-setq (values block node cont last-cont)
  867.                (catch unique-tag
  868.                  (internal-apply-loop node frame-ptr
  869.                           lambda args closure)))
  870.              
  871.              (when (eq values :fell-through)
  872.                ;; We hit a %LEXICAL-EXIT-BREAKUP.
  873.                ;; Interpreting state is set with MV-SETQ above.
  874.                ;; Just get out of this branch and go on.
  875.                (return))
  876.              
  877.              (unless (eq values :non-local-go)
  878.                ;; We know we're non-locally exiting from a
  879.                ;; BLOCK with values (saw a RETURN-FROM).
  880.                (ecase (c::continuation-info cont)
  881.                  (:single
  882.                   (eval-stack-push (car values)))
  883.                  ((:multiple :return)
  884.                   (eval-stack-push values))
  885.                  (:unused)))
  886.              ;;
  887.              ;; Start interpreting again at the target, skipping
  888.              ;; the %NLX-ENTRY block.
  889.              (setf node
  890.                    (c::continuation-next
  891.                 (c::block-start
  892.                  (car (c::block-succ block))))))))))))
  893.         (c::exit
  894.          (maybe-trace-nodes node)
  895.          (let* ((incoming-values (c::exit-value node))
  896.             (values (if incoming-values (eval-stack-pop))))
  897.            (cond
  898.         ((eq (c::lambda-environment lambda)
  899.              (c::block-environment (c::continuation-block cont)))
  900.          ;; Local exit.
  901.          ;; Fixup stack top and massage values for destination.
  902.          (eval-stack-set-top
  903.           (eval-stack-local frame-ptr
  904.                     (c:entry-node-info-st-top
  905.                      (cdr (assoc (c::exit-entry node)
  906.                          (c:lambda-eval-info-entries
  907.                           (c::lambda-info lambda)))))))
  908.          (ecase (c::continuation-info cont)
  909.            (:single
  910.             (assert incoming-values)
  911.             (eval-stack-push (car values)))
  912.            ((:multiple :return)
  913.             (assert incoming-values)
  914.             (eval-stack-push values))
  915.            (:unused)))
  916.         (t
  917.          (let ((info (c::find-nlx-info (c::exit-entry node) cont)))
  918.            (throw
  919.             (svref closure
  920.                (position info
  921.                      (c::environment-closure
  922.                       (c::node-environment node))
  923.                      :test #'eq))
  924.             (if incoming-values
  925.             (values values (c::nlx-info-target info) nil cont)
  926.             (values :non-local-go (c::nlx-info-target info)))))))))
  927.         (c::creturn
  928.          (maybe-trace-nodes node)
  929.          (let ((values (eval-stack-pop)))
  930.            (eval-stack-set-top frame-ptr)
  931.            (return-from internal-apply-loop (values-list values))))
  932.         (c::mv-combination
  933.          (maybe-trace-nodes node)
  934.          (combination-node :mv-call)))
  935.       ;; See function doc below.
  936.       (reference-this-var-to-keep-it-alive node)
  937.       (reference-this-var-to-keep-it-alive frame-ptr)
  938.       (reference-this-var-to-keep-it-alive closure)
  939.       (cond ((not (eq cont last-cont))
  940.          (setf node (c::continuation-next cont)))
  941.         ;; Currently only the last node in a block causes this loop to
  942.         ;; change blocks, so we never just go to the next node when
  943.         ;; the current node's branch tried to change blocks.
  944.         (set-block-p
  945.          (change-blocks))
  946.         (t
  947.          ;; Cif nodes set the block for us, but other last nodes do not.
  948.          (change-blocks (car (c::block-succ block)))))))))
  949.  
  950. ;;; REFERENCE-THIS-VAR-TO-KEEP-IT-ALIVE -- Internal.
  951. ;;;
  952. ;;; This function allows a reference to a variable that the compiler cannot
  953. ;;; easily eliminate as unnecessary.  We use this at the end of the node
  954. ;;; dispatch in INTERNAL-APPLY-LOOP to make sure the node variable has a
  955. ;;; valid value.  Each node branch tends to reference it at the beginning,
  956. ;;; and then there is no reference but a set at the end; the compiler then
  957. ;;; kills the variable between the reference in the dispatch branch and when
  958. ;;; we set it at the end.  The problem is that most error will occur in the
  959. ;;; interpreter within one of these node dispatch branches.
  960. ;;;
  961. (defun reference-this-var-to-keep-it-alive (node)
  962.   node)
  963.  
  964.  
  965. ;;; SET-LEAF-VALUE -- Internal.
  966. ;;;
  967. ;;; This sets a c::cset node's var to value, returning value.  When var is
  968. ;;; local, we have to compare its home environment to the current one, node's
  969. ;;; environment.  If they're the same, we check to see if the var is indirect,
  970. ;;; and store the value on the stack or in the value cell as appropriate.
  971. ;;; Otherwise, var is a closure variable, and since we're setting it, we know
  972. ;;; it's location contains an indirect value object.
  973. ;;;
  974. (defun set-leaf-value (node frame-ptr closure value)
  975.   (let ((var (c::set-var node)))
  976.     (typecase var
  977.       (c::global-var
  978.        (setf (symbol-value (c::global-var-name var)) value))
  979.       (c::lambda-var
  980.        (set-leaf-value-lambda-var node var frame-ptr closure value)))))
  981.  
  982. ;;; SET-LEAF-VALUE-LAMBDA-VAR -- Internal Interface.
  983. ;;;
  984. ;;; This does SET-LEAF-VALUE for a lambda-var leaf.  The debugger tools'
  985. ;;; internals uses this also to set interpreted local variables.
  986. ;;;
  987. (defun set-leaf-value-lambda-var (node var frame-ptr closure value)
  988.   (let ((env (c::node-environment node)))
  989.     (cond ((not (eq (c::lambda-environment (c::lambda-var-home var))
  990.             env))
  991.        (setf (indirect-value
  992.           (svref closure
  993.              (position var (c::environment-closure env)
  994.                    :test #'eq)))
  995.          value))
  996.       ((c::lambda-var-indirect var)
  997.        (setf (indirect-value
  998.           (eval-stack-local frame-ptr (c::lambda-var-info var)))
  999.          value))
  1000.       (t
  1001.        (setf (eval-stack-local frame-ptr (c::lambda-var-info var))
  1002.          value)))))
  1003.  
  1004. ;;; LEAF-VALUE -- Internal.
  1005. ;;;
  1006. ;;; This figures out how to return a value for a ref node.  Leaf is the ref's
  1007. ;;; structure that tells us about the value, and it is one of the following
  1008. ;;; types:
  1009. ;;;    constant   -- It knows its own value.
  1010. ;;;    global-var -- It's either a value or function reference.  Get it right.
  1011. ;;;    local-var  -- This may on the stack or in the current closure, the
  1012. ;;;              environment for the lambda INTERNAL-APPLY is currently
  1013. ;;;             executing.  If the leaf's home environment is the same
  1014. ;;;             as the node's home environment, then the value is on the
  1015. ;;;             stack, else it's in the closure since it came from another
  1016. ;;;             environment.  Whether the var comes from the stack or the
  1017. ;;;             closure, it could have come from a closure, and it could
  1018. ;;;             have been closed over for setting.  When this happens, the
  1019. ;;;             actual value is stored in an indirection object, so
  1020. ;;;             indirect.  See COMPUTE-CLOSURE for the description of
  1021. ;;;             the structure of the closure argument to this function.
  1022. ;;;    functional -- This is a reference to an interpreted function that may
  1023. ;;;             be passed or called anywhere.  We return a real function
  1024. ;;;             that calls INTERNAL-APPLY, closing over the leaf.  We also
  1025. ;;;             have to compute a closure, running environment, for the
  1026. ;;;             lambda in case it references stuff in the current
  1027. ;;;             environment.  If the closure is empty and there is no
  1028. ;;;                  functional environment, then we use
  1029. ;;;                  MAKE-INTERPRETED-FUNCTION to make a cached translation.
  1030. ;;;                  Since it is too late to lazily convert, we set up the
  1031. ;;;                  EVAL-FUNCTION to be already converted. 
  1032. ;;;
  1033. (defun leaf-value (node frame-ptr closure)
  1034.   (let ((leaf (c::ref-leaf node)))
  1035.     (typecase leaf
  1036.       (c::constant
  1037.        (c::constant-value leaf))
  1038.       (c::global-var
  1039.        (locally (declare (optimize (safety 1)))
  1040.      (if (eq (c::global-var-kind leaf) :global-function)
  1041.          (let ((name (c::global-var-name leaf)))
  1042.            (if (symbolp name)
  1043.            (symbol-function name)
  1044.            (fdefinition name)))
  1045.          (symbol-value (c::global-var-name leaf)))))
  1046.       (c::lambda-var
  1047.        (leaf-value-lambda-var node leaf frame-ptr closure))
  1048.       (c::functional
  1049.        (let* ((calling-closure (compute-closure node leaf frame-ptr closure))
  1050.           (real-fun (c::functional-entry-function leaf))
  1051.           (arg-doc (c::functional-arg-documentation real-fun)))
  1052.      (cond ((c:lambda-eval-info-function (c::leaf-info leaf)))
  1053.            ((and (zerop (length calling-closure))
  1054.              (null (c::lexenv-functions
  1055.                 (c::functional-lexenv real-fun))))
  1056.         (let* ((res (make-interpreted-function
  1057.                  (c::functional-inline-expansion real-fun)))
  1058.                (eval-fun (get-eval-function res)))
  1059.           (push eval-fun *interpreted-function-cache*)
  1060.           (setf (eval-function-definition eval-fun) leaf)
  1061.           (setf (eval-function-converted-once eval-fun) t)
  1062.           (setf (eval-function-arglist eval-fun) arg-doc)
  1063.           (setf (eval-function-name eval-fun) (c::leaf-name real-fun))
  1064.           (setf (c:lambda-eval-info-function (c::leaf-info leaf)) res)
  1065.           res))
  1066.            (t
  1067.         (let ((eval-fun (make-eval-function
  1068.                  :definition leaf
  1069.                  :name (c::leaf-name real-fun)
  1070.                  :arglist arg-doc)))
  1071.           #'(lambda (&rest args)
  1072.               (declare (list args))
  1073.               (internal-apply (eval-function-definition eval-fun)
  1074.                       (cons (length args) args)
  1075.                       calling-closure))))))))))
  1076.  
  1077. ;;; LEAF-VALUE-LAMBDA-VAR -- Internal Interface.
  1078. ;;;
  1079. ;;; This does LEAF-VALUE for a lambda-var leaf.  The debugger tools' internals
  1080. ;;; uses this also to reference interpreted local variables.
  1081. ;;;
  1082. (defun leaf-value-lambda-var (node leaf frame-ptr closure)
  1083.   (let* ((env (c::node-environment node))
  1084.      (temp
  1085.       (if (eq (c::lambda-environment (c::lambda-var-home leaf))
  1086.           env)
  1087.           (eval-stack-local frame-ptr (c::lambda-var-info leaf))
  1088.           (svref closure
  1089.              (position leaf (c::environment-closure env)
  1090.                    :test #'eq)))))
  1091.     (if (c::lambda-var-indirect leaf)
  1092.     (indirect-value temp)
  1093.     temp)))
  1094.  
  1095. ;;; COMPUTE-CLOSURE -- Internal.
  1096. ;;;
  1097. ;;; This computes a closure for a local call and for returned call'able closure
  1098. ;;; objects.  Sometimes the closure is a simple-vector of no elements.  Node
  1099. ;;; is either a reference node or a combination node.  Leaf is either the leaf
  1100. ;;; of the reference node or the lambda to internally apply for the combination
  1101. ;;; node.  Frame-ptr is the current frame pointer for fetching current values
  1102. ;;; to store in the closure.  Closure is the current closure, the currently
  1103. ;;; interpreting lambda's closed over environment.
  1104. ;;;
  1105. ;;; A computed closure is a vector corresponding to the list of closure
  1106. ;;; variables described in an environment.  The position of a lambda-var in
  1107. ;;; this closure list is the index into the closure vector of values.
  1108. ;;;
  1109. ;;; Functional-env is the environment description for leaf, the lambda for which
  1110. ;;; we're computing a closure.  This environment describes which of lambda's
  1111. ;;; vars we find in lambda's closure when it's running, versus finding them
  1112. ;;; on the stack.  For each lambda-var in the functional environment's closure
  1113. ;;; list, if the lambda-var's home environment is the current environment, then
  1114. ;;; get a value off the stack and store it in the closure we're computing.
  1115. ;;; Otherwise that lambda-var's value comes from somewhere else, but we have it
  1116. ;;; in our current closure, the environment we're running in as we compute this
  1117. ;;; new closure.  Find this value the same way we do in LEAF-VALUE, by finding
  1118. ;;; the lambda-var's position in the current environment's description of the
  1119. ;;; current closure.
  1120. ;;;
  1121. (defun compute-closure (node leaf frame-ptr closure)
  1122.   (let* ((current-env (c::node-environment node))
  1123.      (current-closure-vars (c::environment-closure current-env))
  1124.      (functional-env (c::lambda-environment leaf))
  1125.      (functional-closure-vars (c::environment-closure functional-env))
  1126.      (functional-closure (make-array (length functional-closure-vars))))
  1127.     (do ((vars functional-closure-vars (cdr vars))
  1128.      (i 0 (1+ i)))
  1129.     ((null vars))
  1130.       (let ((ele (car vars)))
  1131.     (setf (svref functional-closure i)
  1132.           (etypecase ele
  1133.         (c::lambda-var
  1134.          (if (eq (c::lambda-environment (c::lambda-var-home ele))
  1135.              current-env)
  1136.              (eval-stack-local frame-ptr (c::lambda-var-info ele))
  1137.              (svref closure
  1138.                 (position ele current-closure-vars
  1139.                       :test #'eq))))
  1140.         (c::nlx-info
  1141.          (if (eq (c::block-environment (c::nlx-info-target ele))
  1142.              current-env)
  1143.              (eval-stack-local
  1144.               frame-ptr
  1145.               (c:entry-node-info-nlx-tag
  1146.                (cdr (assoc ;; entry node for non-local extent
  1147.                  (c::cleanup-mess-up (c::nlx-info-cleanup ele))
  1148.                  (c::lambda-eval-info-entries
  1149.                   (c::lambda-info
  1150.                    ;; lambda INTERNAL-APPLY-LOOP tosses around.
  1151.                    (c::environment-function
  1152.                 (c::node-environment node))))))))
  1153.              (svref closure
  1154.                 (position ele current-closure-vars
  1155.                       :test #'eq))))))))
  1156.     functional-closure))
  1157.  
  1158. ;;; INTERNAL-INVOKE -- Internal.
  1159. ;;;
  1160. ;;; INTERNAL-APPLY uses this to invoke a function from the interpreter's stack
  1161. ;;; on some arguments also taken from the stack.  When tail-p is non-nil,
  1162. ;;; control does not return to INTERNAL-APPLY to further interpret the current
  1163. ;;; IR1 lambda, so INTERNAL-INVOKE must clean up the current interpreter's
  1164. ;;; stack frame.
  1165. ;;;
  1166. (defun internal-invoke (arg-count &optional tailp)
  1167.   (let ((args (eval-stack-args arg-count)) ;LET says this init form runs first.
  1168.     (fun (eval-stack-pop)))
  1169.     (when tailp (eval-stack-set-top tailp))
  1170.     (when *internal-apply-node-trace*
  1171.       (format t "(~S~{ ~S~})~%" fun args))
  1172.     (apply fun args)))
  1173.  
  1174. ;;; MV-INTERNAL-INVOKE -- Internal.
  1175. ;;;
  1176. ;;; Almost just like INTERNAL-INVOKE.  We call MV-EVAL-STACK-ARGS, and our
  1177. ;;; function is in a list on the stack instead of simply on the stack.
  1178. ;;;
  1179. (defun mv-internal-invoke (arg-count &optional tailp)
  1180.   (let ((args (mv-eval-stack-args arg-count)) ;LET runs this init form first.
  1181.     (fun (car (eval-stack-pop))))
  1182.     (when tailp (eval-stack-set-top tailp))
  1183.     (when *internal-apply-node-trace*
  1184.       (format t "(~S~{ ~S~})~%" fun args))
  1185.     (apply fun args)))
  1186.  
  1187.  
  1188. ;;; EVAL-STACK-ARGS -- Internal.
  1189. ;;;
  1190. ;;; This returns a list of the top arg-count elements on the interpreter's
  1191. ;;; stack.  This removes them from the stack.
  1192. ;;;
  1193. (defun eval-stack-args (arg-count)
  1194.   (let ((args nil))
  1195.     (dotimes (i arg-count args)
  1196.       (push (eval-stack-pop) args))))
  1197.  
  1198. ;;; MV-EVAL-STACK-ARGS -- Internal.
  1199. ;;;
  1200. ;;; This assumes the top count elements on interpreter's stack are lists.  This
  1201. ;;; returns a single list with all the elements from these lists.
  1202. ;;;
  1203. (defun mv-eval-stack-args (count)
  1204.   (if (= count 1)
  1205.       (eval-stack-pop)
  1206.       (let ((last (eval-stack-pop)))
  1207.     (dotimes (i (1- count))
  1208.       (let ((next (eval-stack-pop)))
  1209.         (setf last
  1210.           (if next (nconc next last) last))))
  1211.     last)))
  1212.  
  1213. ;;; STORE-LET-VARS -- Internal.
  1214. ;;;
  1215. ;;; This stores lambda's vars, stack locals, from values popped off the stack.
  1216. ;;; When a var has no references, the compiler computes IR1 such that the
  1217. ;;; continuation delivering the value for the unreference var appears unused.
  1218. ;;; Because of this, the interpreter drops the value on the floor instead of
  1219. ;;; saving it on the stack for binding, so we only pop a value when the var has
  1220. ;;; some reference.  INTERNAL-APPLY uses this for c::combination nodes
  1221. ;;; representing LET's.
  1222. ;;;
  1223. ;;; When storing the local, if it is indirect, then someone closes over it for
  1224. ;;; setting instead of just for referencing.  We then store an indirection cell
  1225. ;;; with the value, and the referencing code for locals knows how to get the
  1226. ;;; actual value.
  1227. ;;;
  1228. (defun store-let-vars (lambda frame-ptr)
  1229.   (let* ((vars (c::lambda-vars lambda))
  1230.      (args (eval-stack-args (count-if #'c::leaf-refs vars))))
  1231.     (declare (list vars args))
  1232.     (dolist (v vars)
  1233.       (when (c::leaf-refs v)
  1234.     (setf (eval-stack-local frame-ptr (c::lambda-var-info v))
  1235.           (if (c::lambda-var-indirect v)
  1236.           (make-indirect-value-cell (pop args))
  1237.           (pop args)))))))
  1238.  
  1239. ;;; STORE-MV-LET-VARS -- Internal.
  1240. ;;;
  1241. ;;; This is similar to STORE-LET-VARS, but the values for the locals appear on
  1242. ;;; the stack in a list due to forms that delivered multiple values to this
  1243. ;;; lambda/let.  Unlike STORE-LET-VARS, there is no control over the delivery
  1244. ;;; of a value for an unreferenced var, so we drop the corresponding value on
  1245. ;;; the floor when no one references it.  INTERNAL-APPLY uses this for
  1246. ;;; c::mv-combination nodes representing LET's.
  1247. ;;;
  1248. (defun store-mv-let-vars (lambda frame-ptr count)
  1249.   (assert (= count 1))
  1250.   (let ((args (eval-stack-pop)))
  1251.     (dolist (v (c::lambda-vars lambda))
  1252.       (if (c::leaf-refs v)
  1253.       (setf (eval-stack-local frame-ptr (c::lambda-var-info v))
  1254.         (if (c::lambda-var-indirect v)
  1255.             (make-indirect-value-cell (pop args))
  1256.             (pop args)))
  1257.       (pop args)))))
  1258.  
  1259. #|
  1260. ;;; STORE-MV-LET-VARS -- Internal.
  1261. ;;;
  1262. ;;; This stores lambda's vars, stack locals, from multiple values stored on the
  1263. ;;; top of the stack in a list.  Since these values arrived multiply, there is
  1264. ;;; no control over the delivery of each value for an unreferenced var, so
  1265. ;;; unlike STORE-LET-VARS, we have values for variables never used.  We drop
  1266. ;;; the value corresponding to an unreferenced var on the floor.
  1267. ;;; INTERNAL-APPLY uses this for c::mv-combination nodes representing LET's.
  1268. ;;;
  1269. ;;; IR1 represents variables bound from multiple values in a list in the
  1270. ;;; opposite order of the values list.  We use STORE-MV-LET-VARS-AUX to recurse
  1271. ;;; down the vars list until we bottom out, storing values on the way back up
  1272. ;;; the recursion.  You must do this instead of NREVERSE'ing the args list, so
  1273. ;;; when we run out of values, we store nil's in the correct lambda-vars.
  1274. ;;;
  1275. (defun store-mv-let-vars (lambda frame-ptr count)
  1276.   (assert (= count 1))
  1277.   (print  (c::lambda-vars lambda))
  1278.   (store-mv-let-vars-aux frame-ptr (c::lambda-vars lambda) (eval-stack-pop)))
  1279. ;;;
  1280. (defun store-mv-let-vars-aux (frame-ptr vars args)
  1281.   (if vars
  1282.       (let ((remaining-args (store-mv-let-vars-aux frame-ptr (cdr vars) args))
  1283.         (v (car vars)))
  1284.     (when (c::leaf-refs v)
  1285.       (setf (eval-stack-local frame-ptr (c::lambda-var-info v))
  1286.         (if (c::lambda-var-indirect v)
  1287.             (make-indirect-value-cell (car remaining-args))
  1288.             (car remaining-args))))
  1289.     (cdr remaining-args))
  1290.       args))
  1291. |#
  1292.